Option Explicit On

Const ALTO As Integer = 70
Const ANCHO As Integer = 70
Const MARGEN As Integer = 5

Private Sub btnPonImg_Click()
    On Error GoTo error
    Dim hd As Worksheet
    hd = ActiveSheet
    Dim agregar As Boolean
    Dim f, top_ant As Integer
    f = 0
    top_ant = 0
    Dim Fso As FileSystemObject
    Dim directorio As Folder
    Fso = New FileSystemObject
    directorio = Fso.GetFolder(tbDir.Text)
    Dim fichero As file
    Dim ruta As String
    For Each fichero In directorio.Files
        Dim partes As Object
        partes = Split(fichero, ".")
        Dim extension As String
        extension = LCase(partes(UBound(partes)))
        agregar = False
        If extension = "jpg" Or extension = "jpeg" Or extension = "gif" Or extension = "tiff" Or extension = "bmp" Or extension = "ico" Or extension = "png" Then
            agregar = True
        End If
        If agregar Then
            ruta = directorio.Path & "\" & fichero.Name
            f = f + 1
            hd.Cells(f, 1).Select()
            hd.Rows(f & ":" & f).RowHeight = ALTO + MARGEN
            hd.Columns("A").ColumnWidth = ANCHO / 5.5
            hd.Shapes.AddPicture(Filename:=ruta, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=0, Top:=top_ant, Width:=ANCHO, Height:=ALTO)
            top_ant = top_ant + ALTO + MARGEN
            hd.Cells(f, 2).Select()
            hd.Hyperlinks.Add(Anchor:=Selection, Address:=ruta, _
            TextToDisplay:=ruta)
            With Selection
                .HorizontalAlignment = xlGeneral
                .VerticalAlignment = xlCenter
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = False
            End With
        End If
    Next
    hd.Range("A:B").Columns.AutoFit()
    hd.Cells(1, 1).Select()
    Exit Sub
error:
    MsgBox(Err.Description)
End Sub

Private Sub btnSalir_Click()
    Unload(Me)
End Sub

Private Sub btnSelDir_Click()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = tbDir.Text
        .Show()
        If .SelectedItems.Count > 0 Then
            tbDir.Text = .SelectedItems(1)
        End If
        If .SelectedItems.Count > 0 Then
            Debug.Print.SelectedItems(1)
        End If
    End With
End Sub

Private Sub UserForm_Initialize()
    Dim WS As Object
    WS = CreateObject("WScript.Shell")
    tbDir.Text = WS.SpecialFolders("MyDocuments")
    WS = Nothing
End Sub
